home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops ƒ / Args next >
Text File  |  1993-02-20  |  6KB  |  231 lines
  1. \ Support for named parms and local variables
  2.  
  3.    24    constant    MAXPL        \ Should be enough!!
  4. false    value        LOCFLG        \ true = looking for local var tokens
  5.  
  6.  
  7. create    PARMLIST    maxPL cells  reserve
  8.  
  9.     0    value    SVHASH
  10. false    value    FLOAT?
  11.  
  12.  
  13. : FINDINPARMLIST        \ ( addr -- loc# T  OR  -- F )
  14.             \ loc# counts from right to left in the local/parm list.
  15.  
  16.     dup 1+ c@   & %  =  -> float?
  17.     hash -> svHash  false
  18.     #PL  0exit
  19.     ParmList  #PL 4*  bounds  DO
  20.         svHash  i @ =
  21.         IF  ( found )
  22.             drop  #PL
  23.             i parmlist -  4/
  24.             -  1-  true  LEAVE
  25.         THEN
  26.     4 +LOOP  ;
  27.  
  28. : ADDTOPARMLIST        \ ( addr -- )  Adds an element to ParmList.
  29.                     \  addr points to a counted string.
  30.     findinParmList  ?error 95        \ Name not unique
  31.     #PL  maxPL  >=  ?error 110
  32.     FltFlg  1 <<   float? if  1 or  1 ++> #F  then  -> FltFlg
  33.     svHash
  34.     #PL  1 ++> #PL  4*  ParmList +  !  ;
  35.  
  36. : FIRSTCHR
  37.     here 1+ c@  ;
  38.  
  39. : {        immediate
  40.     local? if  local? 0< ?error 92  -1 -> local?  then
  41.     0 -> #PL  0 -> #P  0 -> #F  0 -> FltFlg  false -> locFlg
  42.     BEGIN    Mword drop            \ Add parms or vars to parmlist
  43.         firstChr  & -  <>        \ look for --
  44.     WHILE
  45.         firstChr dup  & \  =  swap  & /  =  or
  46.                 \ Note: we're now allowing / as an alternative to \
  47.  
  48.         IF        true -> locFlg
  49.         ELSE    firstChr  & } =  ?error 111
  50.             locFlg nif  1 ++> #P  then
  51.             here  AddToParmList
  52.         THEN
  53.     REPEAT
  54.     local? NIF  PLentry  THEN        \ In local sections, we do it at :LOC
  55.     & }  parse 2drop                \ eat characters until }
  56.     source nip  0< ?error 112  ;    \ Err if no final }
  57.  
  58.  
  59. \ FIND will call Pfind to attempt to find a name first.
  60. \ If Pfind finds the name is a local, it returns true and the
  61. \ cfa of LocParm, which is a dummy word whose handler compiles
  62. \ a local reference.
  63.  
  64. : PFIND        \ ( str-addr -- cfa T  |  -- str-addr F )
  65.     state
  66.     NIF        false
  67.     ELSE    dup  FindInParmList
  68.         IF                        \ Found
  69.             -> loc#  drop
  70.             float? IF  ['] FlocParm  ELSE  ['] locParm  THEN
  71.             true
  72.         ELSE    false            \ Not found
  73.         THEN
  74.     THEN   ;
  75.  
  76.  
  77. : ,EXEC        \ ( cfa n -- )
  78.     state
  79.     IF  (compN)  ELSE  exN  THEN  ;
  80.  
  81. \ Here are the different types that we can put prefixes on or send
  82. \ messages to:
  83.  
  84. TYPE{  notfnd  locTyp  flocTyp  objTyp  classTyp  valTyp  fvalTyp  vecTyp
  85.     objptrTyp  wordTyp  regTyp  lbTyp  lbSelfTyp  bktTyp  }
  86.  
  87. \ notFnd    - not previously defined
  88. \ locTyp    - a local or named parm
  89. \ objTyp    - an object
  90. \ classTyp    - a class
  91. \ valTyp    - a value
  92. \ FvalTyp    - a floating point value
  93. \ vecTyp    - a vector
  94. \ wordTyp    - an ordinary word
  95. \ regTyp    - a 680x0 register
  96. \ lbTyp        - ** or [] meaning late bind
  97. \ lbSelfTyp    - [self] meaning late bind to self
  98. \ BktTyp    - [ - Neon-compatible late bind
  99.  
  100. \ PRFTOKEN returns the type of a token for a prefix op.
  101.  
  102. \ First we need to make some handler codes available above the Nucleus.
  103.  
  104. : HDLR        \ ( cfa -- ha )
  105.     2- w@x  ;
  106.  
  107. ' key    hdlr    constant    VECTCODE
  108. ' base    hdlr    constant    VALCODE
  109. ' ^base    hdlr    constant    REGCODE
  110. ' hdlr    hdlr    constant    WORDCODE
  111.  
  112.     objPtr    XX  ' xx  hdlr        forget xx
  113.         constant    OBJPTRCODE
  114.  
  115. : PRFTOKEN    \ ( -- cfa type )
  116.     '  dup  ['] locParm  =  IF  locTyp    EXIT  THEN
  117.        dup  ['] FlocParm =  IF  FlocTyp    EXIT  THEN
  118.     dup  hdlr
  119.     CASE
  120.         valCode        OF    valTyp        ENDOF
  121.         FvalCode    OF    FvalTyp        ENDOF
  122.         vectCode    OF    vecTyp        ENDOF
  123.         regCode        OF    regTyp        ENDOF
  124.         objPtrCode    OF    objPtrTyp    ENDOF
  125.         ?error 114
  126.     ENDCASE  ;
  127.  
  128.  
  129. forward    ToObjPtr        \ Stores to an objPtr.  Defined in file Class.
  130.  
  131. : ->        immediate
  132.     PrfToken                \ All types are legal
  133.     objPtrTyp =  if  toObjPtr  exit  then
  134.     $ 60  ( opcode for Store )  ,exec  ;
  135.                         \ NOTE: opcode for store hard coded here!!!
  136.  
  137. : CvrtFcode    \ ( code -- code' )
  138.     CASE
  139.         $ 21  OF  $ 41  ENDOF        \ +
  140.         $ 22  OF  $ 48  ENDOF        \ -
  141.         $ 28  OF  $ 55  ENDOF        \ Neg
  142.         ?error 114
  143.     ENDCASE  ;
  144.  
  145. : (+->)        \ ( code -- cfa code' )
  146.     PrfToken ( code cfa type )  rot swap ( cfa code type )
  147.     SELECT{
  148.         locTyp        IS{                }END
  149.         FlocTyp        IS{  CvrtFcode    }END
  150.         valTyp        IS{                }END
  151.         FvalTyp        IS{  CvrtFcode    }END
  152.         regTyp        IS{                }END
  153.  
  154.         DEFAULT{  ?error 114
  155.     }SELECT  ;
  156.  
  157. : (FOP)
  158.     PrfToken  rot swap
  159.     SELECT{
  160.         locTyp        IS{    }END
  161.         FlocTyp        IS{    }END
  162.         FvalTyp        IS{    }END
  163.         DEFAULT{    ?error 114
  164.     }SELECT  ;
  165.  
  166. \ Note: the following opcodes have to agree with the definitions in
  167. \ OD.asm.  I could have defined them as constants but this would have
  168. \ used up dictionary space for no great benefit.
  169.  
  170. : ++>    $ 21  (+->)  ,exec  ;        immediate
  171. : +>    postpone  ++>       ;        immediate        \ A synonym.
  172. : -->    $ 22  (+->)  ,exec  ;        immediate
  173. : AND>    $ 23  (+->)  ,exec  ;        immediate
  174. : OR>    $ 24  (+->)  ,exec  ;        immediate
  175. : XOR>    $ 25  (+->)  ,exec  ;        immediate
  176. : NEG>    $ 28  (+->)  ,exec  ;        immediate
  177. : NOT>    $ 29  (+->)  ,exec  ;        immediate
  178. : *>    $ 42  (fop)  ,exec  ;        immediate
  179. : />    $ 49  (fop)  ,exec  ;        immediate
  180. : ABS>    $ 54  (fop)  ,exec  ;        immediate
  181.  
  182. ' Pfind  -> Ufind
  183.  
  184. \         =========== Local sections ===========
  185.  
  186. : ?LOC    local? not  ?error 91  ;
  187.  
  188. : LOCAL
  189.     local?  ?error 93  1 -> local?        \ We change it to the normal -1
  190.                     \ as soon as "{" is read.
  191.     forward  ;
  192.  
  193. : :LOC        immediate
  194.     ?loc  ?exec  304
  195.     here  '  (patch)            \ Like :F
  196.     #PL  if  PLentry  then
  197.     false -> local?            \ We do this here so any EXITs
  198.                             \  tidy everything up properly
  199.     postpone ]  ;
  200.  
  201. : ;LOC        immediate
  202.     (;)  304 ?defn  ;        \ As local? is now false, everything else
  203.                             \ gets tidied up by (;)
  204.  
  205.  
  206. : EVALUATE  { addr len \ cnt -- ?? }
  207.  
  208.     save-input  -> cnt
  209.     cnt for  >r  next            \ Move input-stream specs to rtn stk
  210.     addr -> src-start  len -> src-len  0 >in !  -1 -> source-id
  211.     echo?  IF  ." ***evaluating***  "  addr len type cr  THEN
  212.     interpret
  213.     cnt for  r>  next
  214.     cnt restore-input  ?error 25  ;
  215.  
  216.  
  217. : (COMPINL)    \ ( cfa -- )
  218.     2+ count  evaluate  ;
  219.  
  220. ' (compinl) -> compinline
  221.  
  222. : INLINE{        immediate
  223.     method? IF  -4 allot  THEN        \ Wipe out method entry sequence
  224.     inlMk w,  & }  ,str
  225.     align-dp
  226.     method? IF  Mentry  THEN        \ Recompile method entry sequence
  227.     postpone ]  ;
  228.  
  229.  
  230. <" Class
  231.